home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / ftpser1a / module1.bas < prev    next >
BASIC Source File  |  1999-08-23  |  9KB  |  198 lines
  1. Attribute VB_Name = "Module1"
  2. Option Explicit
  3.  
  4. Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  5. Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal wndrpcPrev As Long, ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, lParam As Any) As Long
  6. Public Const GWL_WNDPROC = (-4)
  7.  
  8. Public intSocket As Integer
  9. Public OldWndProc As Long
  10. Public IPDot As String
  11.  
  12. Public Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  13.  
  14. Dim retf As Long
  15. Dim SendBuffer As String, Msg$
  16. Dim lenBuffer As Integer 'send-buffer lenght
  17. Dim RecvBuffer As String
  18. Dim BytesRead As Integer 'receive-buffer lenght
  19. Dim i As Integer, GoAhead As Boolean
  20. Dim fixstr As String * 1024
  21. Dim lct As String
  22. Dim lcv As Integer
  23. Dim WSAEvent As Long
  24. Dim WSAError As Long
  25.   GoAhead = True
  26.   Select Case uMsg
  27.   Case 5150
  28.     FtpServ.LogWnd.AddItem "NOTIFICATION - " & wParam & " - " & lParam & "> " & Format$(Date$, "dd/mm/yy ") & Format$(Time$, "hh:mm - ")
  29.     If (wParam = ServerSlot) Or (wParam = NewSlot) Then 'event on server slot
  30.       'FtpServ.StatusBar.Panels(1) = CStr(wParam)
  31.       WSAEvent = WSAGetSelectEvent(lParam)
  32.       WSAError = WSAGetAsyncError(lParam)
  33.       'Debug.Print "Retf = "; WSAEvent; WSAError
  34.       Select Case WSAEvent
  35.         'FD_READ    = &H1    = 1
  36.         'FD_WRITE   = &H2    = 2
  37.         'FD_OOB     = &H4    = 4
  38.         'FD_ACCEPT  = &H8    = 8
  39.         'FD_CONNECT = &H10   = 16
  40.         'FD_CLOSE   = &H20   = 32
  41.       Case FD_CONNECT
  42.         Debug.Print "FD_Connect " & wParam; lParam
  43.         retf = getpeername(NewSlot, SockAddr, SockAddr_Size)
  44.         Debug.Print "Peername = " & retf
  45.         Debug.Print "IPAddr1 =" & SockAddr.sin_addr
  46.         Debug.Print "IPPort1 =" & SockAddr.sin_port
  47.       Case FD_ACCEPT
  48.         Debug.Print "Doing FD_Accept"
  49.  
  50.         SockAddr.sin_family = AF_INET
  51.         SockAddr.sin_port = 0
  52.         'SockAddr.sin_addr = 0
  53.         NewSlot = accept(ServerSlot, SockAddr, SockAddr_Size) 'try to accept new TCP connection
  54.         If NewSlot = INVALID_SOCKET Then
  55.           Msg$ = "Can't accept new socket."
  56.           'FtpServ.StatusBar.Panels(1) = Msg$ & CStr(NewSlot)
  57.  
  58.         Else
  59.           Debug.Print "NewSlot OK "; NewSlot; num_users; MAX_N_USERS
  60.           retf = getpeername(NewSlot, SockAddr, SockAddr_Size)
  61.           IPDot = GetAscIP(SockAddr.sin_addr)
  62.           FtpServ.StatusBar.Panels(1) = IPDot & "<>" & vbGetHostByAddress(IPDot)
  63.           Debug.Print "Peername = " & retf
  64.           Debug.Print "IPAddr2 =" & SockAddr.sin_addr & " IPdot=" & IPDot
  65.           Debug.Print "IPPort2 =" & SockAddr.sin_port & " Port:" & ntohs(SockAddr.sin_port)
  66.           If num_users >= MAX_N_USERS Then        'new service request
  67.             'the number of users exceeds the maximum allowed
  68.             SendBuffer = "421 Service not available at this time, closing control connection." & vbCrLf
  69.             lenBuffer = Len(SendBuffer)
  70.             retf = send(NewSlot, SendBuffer, lenBuffer, 0)
  71.             retf = closesocket(NewSlot)           'close connection
  72.           Else
  73.             SendBuffer = "220-Welcome to my demo FTP Server v.0.1!" & vbCrLf _
  74.                        & "220 This program is written in VB 5.0" & vbCrLf
  75.             lenBuffer = Len(SendBuffer)
  76.             retf = send(NewSlot, SendBuffer, lenBuffer, 0)          'send welcome message
  77.             Debug.Print "Send = " & retf
  78.             num_users = num_users + 1      'increases the number of connected users
  79.             FtpServ.UsrCnt = CStr(num_users)
  80.             For i = 1 To MAX_N_USERS       'registers the slot number in the first free user record
  81.               If Not users(i).full Then
  82.                 users(i).control_slot = NewSlot
  83.                 users(i).full = True
  84.                 Exit For
  85.               End If
  86.             Next
  87.           End If  'If num_users
  88.         End If  'If NewSlot
  89.       Case FD_READ
  90.         Debug.Print "Doing FD_Read"
  91.         BytesRead = recv(wParam, fixstr, 1024, 0) 'store read bytes in RecvBuffer
  92.         RecvBuffer = Left$(fixstr, BytesRead)
  93.         If InStr(RecvBuffer, vbCrLf) > 0 Then     'if received string is a command then executes it
  94.           For i = 1 To MAX_N_USERS                'event on control slots
  95.             If (wParam = users(i).control_slot) Then
  96.               retf = exec_FTP_cmd(i, RecvBuffer)
  97.             End If
  98.           Next
  99.         End If
  100.       Case FD_CLOSE
  101.         Debug.Print "Doing FD_Close"
  102.         For i = 1 To MAX_N_USERS  'event on control slots
  103.           If (wParam = users(i).control_slot) Then
  104.             retf = closesocket(wParam)        'connection closed by client
  105.             users(i).control_slot = INVALID_SOCKET        'frees the user record
  106.             users(i).full = False
  107.             FtpServ.LogWnd.AddItem "<" & Format$(i, "000") & "> " & Format$(Date$, "dd/mm/yy ") & Format$(Time$, "hh:mm") & " - Logged Off"
  108.             num_users = num_users - 1
  109.             FtpServ.UsrCnt = CStr(num_users)
  110.             Exit For
  111.           ElseIf (wParam = users(i).data_slot) Then
  112.             retf = closesocket(wParam)        'connection closed by client
  113.             users(i).data_slot = INVALID_SOCKET   'reinitilizes data slot
  114.             users(i).state = 2
  115.             Exit For
  116.           End If
  117.        Next
  118.       Case FD_WRITE
  119.         Debug.Print "Doing FD_Write"
  120.         'enables sending
  121.       End Select
  122.     End If
  123.     'Debug.Print GetWSAErrorString(WSAGetLastError)
  124.   End Select
  125.     retf = CallWindowProc(OldWndProc, hWnd, uMsg, wParam, ByVal lParam)
  126.     'If (uMsg = 5150) Then
  127.     '  Debug.Print retf; OldWndProc; hWnd; uMsg; wParam; lParam; WSAGetLastError
  128.     'End If
  129.     WindowProc = retf
  130. End Function
  131.  
  132. ' ************* OLD CODE **************
  133. '         If retf = FD_ACCEPT Then    '--- FD_ACCEPT
  134. '           NewSlot = acceptSocket(ServerSlot)      'try to accept new TCP connection
  135. '           If NewSlot = INVALID_SOCKET Then
  136. '             Msg$ = "Error during an attempt at connection." & CStr(NewSlot)
  137. '             FtpServ.StatusBar.Panels(1) = Msg$
  138. '           Else
  139. '             Debug.Print "NewSlot OK"
  140. '             If num_users >= MAX_N_USERS Then        'new service request
  141. '               'the number of users exceeds the maximum allowed
  142. '               SendBuffer = "421 Service not available at this time, closing control connection." & vbCrLf
  143. '               lenBuffer = Len(SendBuffer)
  144. '               retf = send(NewSlot, SendBuffer, lenBuffer, 0)
  145. '               retf = CloseSocket(NewSlot)           'close connection
  146. '             Else
  147. '               SendBuffer = "220-Welcome in this demo site!" & vbCrLf _
  148. '                          & "220-The software implementing this FTP is entirely written in VB 5.0" & vbCrLf _
  149. '                          & "220-You must consider the packet as a demo version only!" & vbCrLf _
  150. '                          & "220 Have a good time ... (Jay L. Bray)" & vbCrLf
  151. '               lenBuffer = Len(SendBuffer)
  152. '               retf = send(NewSlot, SendBuffer, lenBuffer, 0)          'send welcome message
  153. '               num_users = num_users + 1          'increases the number of connected users
  154. '               For i = 1 To MAX_N_USERS          'registers the slot number in the first free user record
  155. '                 If Not users(i).full Then
  156. '                   users(i).control_slot = NewSlot
  157. '                   users(i).full = True
  158. '                   Exit For
  159. '                 End If
  160. '               Next
  161. '             End If  'If num_users
  162. '           End If  'If NewSlot
  163. '         End If  'If retf
  164. '         GoAhead = False
  165. '       End If  'If wparam
  166. '       For i = 1 To MAX_N_USERS  'event on control slots
  167. '         If (wParam = users(i).control_slot) Then
  168. '           retf = WSAGetSelectEvent(lParam)
  169. '           If retf = FD_READ Then       '--- FD_READ
  170. '             BytesRead = recv(wParam, fixstr, 1024, 0)        'store read bytes in RecvBuffer
  171. '             RecvBuffer = Left